home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / object.t < prev    next >
Encoding:
Text File  |  1988-05-02  |  3.8 KB  |  94 lines
  1. (herald object (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; object related macros
  27.                                  
  28. (define-syntax (fix-up-default pat body)
  29.   (cond ((atom? body) 'nil)
  30.         (else
  31.           (destructure (((name . args) pat))
  32.             (let ((ignore-list (iterate loop ((args args) (l '()))
  33.                                  (cond ((null? args) l)
  34.                                        ((atom? args) (cons args l))
  35.                                        (else
  36.                                         (loop (cdr args) (cons (car args) l)))))))
  37.               `(named-lambda ,name ,args
  38.                   (ignorable ,@ignore-list)
  39.                   ,@body))))))
  40.  
  41.  
  42. (define-syntax (operation default . clauses)
  43.   `(%operation (%massage-default ,default)
  44.                nil
  45.                (join-methods handle-operation
  46.                ,@clauses)))
  47.  
  48. (define-syntax (define-operation pat . body)
  49.   (let ((pat (if (pair? pat) pat (cons pat '()))))
  50.     `(define ,(car pat)
  51.        (%operation  
  52.          (fix-up-default ,pat ,body)
  53.          ',(car pat)
  54.          handle-operation))))
  55.  
  56. (define-syntax (define-settable-operation pat . body)
  57.   (let ((pat (if (pair? pat) pat (cons pat '()))))
  58.     `(define ,(car pat)
  59.        (%settable-operation (fix-up-default ,pat ,body)
  60.                           ',(car pat)))))
  61.  
  62. (define-syntax (define-predicate id)
  63.   `(define ,id (%predicate ',id)))  ; Hair this up later
  64.  
  65. (define-syntax (join-methods handler . clauses)
  66.   (if (null? clauses)
  67.       handler
  68.      `(join (object nil ,@clauses) ,handler)))
  69.  
  70. (define-syntax (define-methods handler . clauses)
  71.   `(set ,handler (join (object nil ,@clauses) ,handler)))
  72.  
  73. (define (expand-object-form form)
  74.   (destructure (((proc . clauses) form))
  75.     (let ((op (generate-symbol 'op)))
  76.       `(*object ,proc (lambda (,op)
  77.                         (select ,op
  78.                           ,@(map construct-method clauses)
  79.                           (else nil)))))))
  80.  
  81. (define (construct-method clause)
  82.   (cond ((pair? (car clause))     
  83.          (destructure ((((op state . vars) . body) clause))
  84.            (if (atom? state)        ; old form
  85.                `((,op) (lambda (,state #f ,@vars)
  86.                            (ignorable ,state)
  87.                            ,@body))
  88.                (destructure (((self obj) state))
  89.                  `((,op) (lambda (,self ,obj ,@vars)
  90.                              ,@body))))))
  91.         (else
  92.          `((,(car clause)) ,@(cdr clause)))))
  93.            
  94.